home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / UTILITY / MISC.lisp < prev    next >
Encoding:
Text File  |  1990-06-25  |  8.6 KB  |  184 lines  |  [TEXT/MACA]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         MISC.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      15-Oct-86 01:37:00
  17. ; Modified:     22-Jun-90 02:01:48 (Dan Suthers)
  18. ; Language:     LISP
  19. ; Package:      UTILS
  20. ;
  21. ; Description:  Miscellaneous utility functions that didn't fit well elsewhere.
  22. ;
  23. ; (c) Copyright 1987, by Daniel D. Suthers
  24. ;                        Department of Computer and Information Science
  25. ;                        University of Massachusetts
  26. ;                        Amherst, Massachusetts 01003
  27. ;
  28. ; This software was conceived, designed, and written by Dan Suthers 
  29. ; while supported by the National Science Foundation under grant number
  30. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  31. ; CA.  Partial support was also received from the Office of Naval Research
  32. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  33. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  34. ; the above grants and encouraged me to pursue my own research interests in
  35. ; her lab.  This work would not have been possible without the resources and
  36. ; stimulating environment of the Computer and Information Science department.
  37. ;
  38. ; Permission to use, modify, and distribute this software is granted subject 
  39. ; to the following restrictions and understandings:
  40. ; 1. The file header, including this notice, shall be retained, and may be
  41. ;    extended to include documentation of modifications to the software.
  42. ; 2. This material is for nonprofit educational and research purposes only.
  43. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  44. ;    noteworthy uses of this software.
  45. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  46. ;    representation that the operation of this software will be error free,
  47. ;    and are under no obligation to provide any services.
  48. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  49. ;    Suthers and the University of Massachusetts from all claims arising 
  50. ;    out of the use or misuse of this software, or arising out of any 
  51. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  52. ;    fees, and liabilities incurred in or about any such claim, action, or
  53. ;    proceeding brought thereon.
  54. ; 5. All materials and reports developed as a consequence of the use of 
  55. ;    this software shall duly acknowledge such use, in accordance with
  56. ;    the usual standards of acknowledging credit in academic research.
  57. ;
  58. ; Status:       Working.
  59. ;
  60. ; Changes:
  61. ;   Nov-27-88: UNIQUE-SYMBOL fixed to check that INTERN did not find it!  
  62. ;     Also, separate counters now kept for each package.
  63. ;   06-Apr-89: Added INDENT-STRING, deleted SILENT-WARNING.
  64. ;
  65. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66.  
  67. (in-package :UTILS)
  68.  
  69. (export '(
  70.           INDENT-STRING
  71.           RESET-PREFIX-COUNTER
  72.           UNIQUE-SYMBOL
  73.           NEXT-UNIQUE-SYMBOL
  74.  
  75.   ))
  76.  
  77. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78.  
  79. (let ((*label-counters* nil))
  80.   
  81.   (defun UNIQUE-SYMBOL (prefix &optional (in-package *package*))
  82.     "unique-symbol <prefix> &optional <package>                       [Function]
  83.   A gentemp variant: returns a unique interned symbol.  Difference is it 
  84.   always counts from 1 for each new prefix, so you get pretty names."
  85.     (check-type prefix string)
  86.     (check-type in-package package)
  87.     (let* ((package-entry
  88.             (or (assoc in-package *label-counters*)
  89.                 (let ((new-entry (cons in-package nil)))
  90.                   (push new-entry *label-counters*)
  91.                   new-entry)))
  92.            (counter-entry
  93.             (or (assoc prefix (cdr package-entry) :test #'string=)
  94.                 (let ((new-entry (cons prefix 0)))
  95.                   (push new-entry (cdr package-entry))
  96.                   new-entry))))
  97.       (incf (cdr counter-entry))
  98.       (multiple-value-bind
  99.         (interned-symbol already-existed)
  100.         (intern (format nil "~A~A"
  101.                         prefix (cdr counter-entry)) in-package)
  102.         (if already-existed 
  103.           (unique-symbol prefix in-package)
  104.           interned-symbol))))
  105.  
  106.   (defun NEXT-UNIQUE-SYMBOL (prefix &optional (in-package *package*))
  107.     "next-unique-symbol <prefix> &optional <package>                  [Function]
  108.   Returns a STRING which would be the name of the next unique-symbol if
  109.   the latter was called with the same arguments."
  110.     (check-type prefix string)
  111.     (check-type in-package package)
  112.     (let* ((package-entry
  113.             (or (assoc in-package *label-counters*)
  114.                 (let ((new-entry (cons in-package nil)))
  115.                   (push new-entry *label-counters*)
  116.                   new-entry)))
  117.            (counter
  118.             (cdr (or (assoc prefix (cdr package-entry) :test #'string=)
  119.                      (let ((new-entry (cons prefix 0)))
  120.                        (push new-entry (cdr package-entry))
  121.                        new-entry)))))
  122.       (incf counter)
  123.       (loop
  124.         (let ((name (format nil "~A~A" prefix counter)))
  125.           (if (find-symbol name in-package)
  126.             (incf counter)
  127.             (return name))))))
  128.  
  129.   (defun RESET-PREFIX-COUNTER (prefix &optional (in-package *package*))
  130.     "reset-prefix-counter <prefix>                                     [Function]
  131.   Resets the UNIQUE-SYMBOL counter for <prefix>.  (Deletes the counter from
  132.   an alist -- you may want to do this to shorten the alist as well.)"
  133.     (let ((package-entry (assoc in-package *label-counters*)))
  134.       (if package-entry
  135.         (setf (cdr package-entry)
  136.               (delete prefix (cdr package-entry) :test #'string= :key #'car)))))
  137.  
  138.   ;; For debugging.
  139.   ;; (defun lc () *label-counters*)
  140.  
  141.   )
  142.  
  143. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  144.  
  145. (defmacro SILENT-WARNING (global-var format-string &rest args)
  146.   "silent-warning <global-var> <format-string> &rest args              [Macro]
  147.   Used to record trace or warning messages on a global list.  Pushes the 
  148.   result of applying <format-string> to <args> onto the symbol <global-var>.
  149.   <Args> will be evaluated."
  150.   `(progn (format T "~%Your code is using obsolete SILENT-WARNING macro! Please rewrite.")
  151.      (push (format nil ,format-string ,.args) ,global-var)
  152.      (car ,global-var)))
  153.  
  154. (defun INDENT-STRING (source-string indentation)
  155.   "indent-string <source-string> <indentation>                      [Function]
  156.   Returns a new simple-string which is identical to the <source-string>,
  157.   except the beginning is indented by <indentation> spaces, and all 
  158.   newlines are followed by <indentation> spaces."
  159.   (declare (string source-string) (fixnum indentation)
  160.            (optimize (safety 1) (space 2) (speed 3)))
  161.   ;; Allocate room for spaces added at beginning and after each newline.
  162.   (let ((target-string-length (+ (* indentation 
  163.                                     (1+ (count #\
  164.                                            source-string)))
  165.                                  (length source-string))))
  166.     (declare (fixnum target-string-length))
  167.     (do ((source-index 0 (1+ source-index))
  168.          (target-index indentation (1+ target-index))
  169.          (target-string (make-string target-string-length :initial-element #\ )))
  170.         ((= target-index target-string-length) target-string)
  171.       (declare (fixnum source-index target-index) (simple-string target-string))
  172.       (setf (schar target-string target-index)
  173.             (char source-string source-index))
  174.       (when (char= #\
  175.                    (char source-string source-index))
  176.         (dotimes (i indentation)
  177.           (incf target-index)
  178.           (setf (schar target-string target-index) #\ ))))))
  179.  
  180. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  181. (provide :MISC)
  182. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  183. ;;; EOF
  184.